home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
PASCAL
/
1372.ZIP
/
PIBCAT.ARC
/
PIBCATS2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-11-07
|
32KB
|
754 lines
(*--------------------------------------------------------------------------*)
(* KeyPressed --- Return TRUE if key pressed *)
(*--------------------------------------------------------------------------*)
FUNCTION KeyPressed : BOOLEAN;
(*--------------------------------------------------------------------------*)
(* *)
(* Function: KeyPressed *)
(* *)
(* Purpose: Return TRUE if key pressed *)
(* *)
(* Calling sequence: *)
(* *)
(* KeyHit := KeyPressed; *)
(* *)
(* KeyHit --- If key hit, return TRUE else FALSE. *)
(* *)
(*--------------------------------------------------------------------------*)
VAR
Regs : Registers;
BEGIN (* KeyPressed *)
Regs.AH := 11;
MSDOS( Regs );
KeyPressed := ( Regs.AL = 255 );
END (* KeyPressed *);
(*--------------------------------------------------------------------------*)
(* TimeOfDayString --- Return current time of day as string *)
(*--------------------------------------------------------------------------*)
FUNCTION TimeOfDayString : AnyStr;
(*--------------------------------------------------------------------------*)
(* *)
(* Function: TimeOfDayString *)
(* *)
(* Purpose: Return current time of day as string *)
(* *)
(* Calling sequence: *)
(* *)
(* Tstring := TimeOfDayString : AnyStr; *)
(* *)
(* Tstring --- Resultant 'HH:MM am/pm' form of time *)
(* *)
(*--------------------------------------------------------------------------*)
VAR
Hours : WORD;
Minutes : WORD;
Seconds : WORD;
SecHun : WORD;
SH : STRING[2];
SM : STRING[2];
AmPm : STRING[2];
BEGIN (* TimeOfDayString *)
GetTime( Hours, Minutes, Seconds, SecHun );
Adjust_Hour( Hours , AmPm );
STR( Hours :2, SH );
STR( Minutes:2, SM );
IF SM[1] = ' ' THEN SM[1] := '0';
TimeOfDayString := SH + ':' + SM + ' ' + AmPm;
END (* TimeOfDayString *);
(*--------------------------------------------------------------------------*)
(* DateString --- Return current date in string form *)
(*--------------------------------------------------------------------------*)
FUNCTION DateString : AnyStr;
(*--------------------------------------------------------------------------*)
(* *)
(* Function: DateString *)
(* *)
(* Purpose: Returns current date in string form *)
(* *)
(* Calling sequence: *)
(* *)
(* Dstring := DateString: AnyStr; *)
(* *)
(* Dstring --- Resultant string form of date *)
(* *)
(* Calls: GetDate *)
(* *)
(*--------------------------------------------------------------------------*)
VAR
SDay: STRING[2];
SYear: STRING[4];
Month: WORD;
Day: WORD;
Year: WORD;
DayOfWeek: WORD;
BEGIN (* DateString *)
(* Date function *)
GetDate( Year, Month, Day, DayOfWeek );
(* Convert date to string *)
STR( ( Year - 1900 ):2 , SYear );
STR( Day :2 , SDay );
DateString := SDay + '-' + Month_Names[ Month ] + '-' + SYear;
END (* DateString *);
(*----------------------------------------------------------------------*)
(* Open_File --- Open untyped file for processing *)
(*----------------------------------------------------------------------*)
PROCEDURE Open_File( FileName : AnyStr;
VAR AFile : FILE;
VAR File_Pos : LONGINT;
VAR Error : INTEGER );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Open_File *)
(* *)
(* Purpose: Opens untyped file (of byte) for input *)
(* *)
(* Calling sequence: *)
(* *)
(* Open_File( FileName : AnyStr; *)
(* VAR AFile : FILE; *)
(* VAR File_Pos : LONGINT; *)
(* VAR Error : INTEGER ); *)
(* *)
(* FileName --- Name of file to open *)
(* AFile --- Associated file variable *)
(* File_Pos --- Initial byte offset in file (always set to 0) *)
(* Error --- = 0: Open went OK. *)
(* <> 0: Open failed. *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Open_File *)
(* Try opening file. Access *)
(* is essentially as file of byte. *)
FileMode := Read_Open_Mode;
ASSIGN( AFile , FileName );
RESET ( AFile , 1 );
FileMode := 2;
(* Check if open went OK or not *)
IF ( IOResult <> 0 ) THEN
Error := Open_Error
ELSE
Error := 0;
(* We are at beginning of file *)
File_Pos := 0;
END (* Open_File *);
(*----------------------------------------------------------------------*)
(* Close_File --- Close an unytped file *)
(*----------------------------------------------------------------------*)
PROCEDURE Close_File( VAR AFile : FILE );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Close_File *)
(* *)
(* Purpose: Closes untyped file *)
(* *)
(* Calling sequence: *)
(* *)
(* Close_File( VAR AFile : FILE ); *)
(* *)
(* AFile --- Associated file variable *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Close_File *)
(* Close the file *)
CLOSE( AFile );
(* Clear error flag *)
IF ( IOResult <> 0 ) THEN;
END (* Close_File *);
(*----------------------------------------------------------------------*)
(* Quit_Found --- Check if ^C hit on keyboard *)
(*----------------------------------------------------------------------*)
FUNCTION QuitFound : BOOLEAN;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Quit_Found *)
(* *)
(* Purpose: Determines if keyboard input is ^C *)
(* *)
(* Calling sequence: *)
(* *)
(* Quit := Quit_Found : BOOLEAN; *)
(* *)
(* Quit --- TRUE if ^C typed at keyboard. *)
(* *)
(* Remarks: *)
(* *)
(* The cataloguing process can be halted by hitting ^C at the *)
(* keyboard. This routine is called when Find_Files notices that *)
(* keyboard input is waiting. If ^C is found, then cataloguing *)
(* stops at the next convenient breakpoint. The global variable *)
(* User_Break indicates that a ^C was found. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Ch : CHAR;
BEGIN (* QuitFound *)
(* Character was hit -- read it *)
READ( Ch );
(* If it is a ^C, set User_Break *)
(* so we halt at next convenient *)
(* location. *)
User_Break := User_Break OR ( Ch = ^C );
QuitFound := User_Break;
(* Purge anything else in keyboard *)
(* buffer *)
WHILE( KeyPressed ) DO
READ( Ch );
END (* QuitFound *);
(*----------------------------------------------------------------------*)
(* Check_Entry_Spec --- Check if entry spec is legitimate *)
(*----------------------------------------------------------------------*)
PROCEDURE Check_Entry_Spec( Entry_Spec : AnyStr;
VAR Entry_Name : String8;
VAR Entry_Ext : String3;
VAR Use_Entry_Spec : BOOLEAN );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Check_Entry_Spec *)
(* *)
(* Purpose: Check_Entry_Spec *)
(* *)
(* Calling sequence: *)
(* *)
(* Check_Entry_Spec( Entry_Spec : AnyStr; *)
(* VAR Entry_Name : String8; *)
(* VAR Entry_Ext : String3; *)
(* VAR Use_Entry_Spec : BOOLEAN ); *)
(* *)
(* Entry_Spec --- The wildcard for .ARC/.LBR contents. *)
(* Entry_Name --- Output 8-char name part of wildcard *)
(* Entry_Ext --- Output 3-char extension part of wildcard *)
(* Use_Entry_Spec --- TRUE if Entry_Spec legitimate and not *)
(* equivalent to a "get all entries." *)
(* *)
(* Remarks: *)
(* *)
(* This routine splits the original wildcard specification into *)
(* two parts: one corresponding to the name portion, and the *)
(* other the extension portion. "*" (match string) characters *)
(* are converted to an appropriate series of "?" (match one char) *)
(* characters. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
ISpec : INTEGER;
IDot : INTEGER;
LSpec : INTEGER;
IOut : INTEGER;
QExt : BOOLEAN;
BEGIN (* Check_Entry_Spec *)
(* Initialize name, extension *)
(* portion of wildcard *)
Entry_Name := '????????';
Entry_Ext := '???';
(* IOut points to name/ext position *)
IOut := 0;
(* ISpec points to wildcard position *)
ISpec := 0;
(* Get length of wildcard *)
LSpec := Min( LENGTH( Entry_Spec ) , 12 );
(* See if '.' appears in Entry_Spec. *)
(* If not, assume one after name part *)
(* of wildcard. *)
IDot := POS( '.' , Entry_Spec );
IF ( IDot = 0 ) THEN
IDot := 9;
(* Point to first character in wildcard *)
ISpec := 1;
(* We start storing in name, not extension *)
QExt := FALSE;
(* Loop over characters in wildcard *)
WHILE( ISpec <= LSpec ) DO
BEGIN
(* Handle '.', '*', '?' specially; copy *)
(* rest directly to either name or *)
(* extension portion of wildcard. *)
CASE Entry_Spec[ISpec] OF
'.': BEGIN
IOut := 0;
QExt := TRUE;
END;
'*': IF QExt THEN
ISpec := 12
ELSE
ISpec := PRED( IDot );
'?': INC( IOut );
ELSE BEGIN
INC( IOut );
IF QExt THEN
Entry_Ext[IOut] := Entry_Spec[ISpec]
ELSE
Entry_Name[IOut] := Entry_Spec[ISpec]
END;
END;
(* Point to next character in wildcard. *)
INC( ISpec );
END;
(* If wildcard turns out to be a *)
(* 'match anything' spec, don't *)
(* bother with any matching later *)
(* on. *)
Use_Entry_Spec := ( Entry_Name <> '????????' ) OR
( Entry_Ext <> '???' );
END (* Check_Entry_Spec *);
(*----------------------------------------------------------------------*)
(* Entry_Matches --- Check if given file name matches entry spec *)
(*----------------------------------------------------------------------*)
FUNCTION Entry_Matches( FileName : AnyStr ) : BOOLEAN;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Entry_Matches *)
(* *)
(* Purpose: Entry_Matches *)
(* *)
(* Calling sequence: *)
(* *)
(* Matches := Entry_Matches( VAR FileName : AnyStr ) : BOOLEAN; *)
(* *)
(* FileName --- name of file to check against entry spec *)
(* Matches --- set TRUE if FileName matches global *)
(* entry spec contained in 'Entry_Spec'. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
IDot : INTEGER;
IPos : INTEGER;
Match : BOOLEAN;
FName : STRING[8];
FExt : STRING[3];
LName : INTEGER;
BEGIN (* Entry_Matches *)
(* Assume match found to start. *)
Match := TRUE;
(* Initialize wildcard form of *)
(* file name and extension. *)
FName := '????????';
FExt := '???';
(* Get length of filename *)
LName := LENGTH( FileName );
(* See if '.' appears in filename. *)
IDot := POS( '.' , FileName );
(* Move name field to wildcard pattern *)
IF ( IDot > 0 ) THEN
BEGIN
MOVE( FileName[1], FName[1], IDot - 1 );
MOVE( FileName[IDot+1], FExt [1], LName - IDot )
END
ELSE
MOVE( FileName[1], FName[1], LName );
(* IPos has position in name portion *)
IPos := 0;
(* Try matching name portion of file name *)
(* with wildcard for name portion. *)
REPEAT
INC( IPos );
IF ( Entry_Name[IPos] <> '?' ) THEN
Match := Match AND ( FName[IPos] = Entry_Name[IPos] );
UNTIL ( NOT Match ) OR ( IPos = 8 );
(* IPos has position in extension portion *)
IPos := 0;
(* Try matching extension portion of file *)
(* name with wildcard for extension *)
(* portion. Unnecessary if name portions *)
(* didn't match. *)
IF Match THEN
REPEAT
INC( IPos );
IF ( Entry_Ext[IPos] <> '?' ) THEN
Match := Match AND ( FExt[IPos] = Entry_Ext[IPos] );
UNTIL ( NOT Match ) OR ( IPos = 3 );
Entry_Matches := Match;
END (* Entry_Matches *);
(*----------------------------------------------------------------------*)
(* DOS_Version --- Get DOS version *)
(*----------------------------------------------------------------------*)
FUNCTION DOS_Version : INTEGER;
(*----------------------------------------------------------------------*)
(* *)
(* Function: DOS_Version *)
(* *)
(* Purpose: Return current DOS version. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Regs : Registers;
BEGIN (* DOS_Version *)
(* Request DOS version *)
Regs.AH := $30;
MSDOS( Regs );
DOS_Version := Regs.AL * 10 + Regs.AH;
END (* DOS_Version *);
(*----------------------------------------------------------------------*)
(* Heap_Error_Handler --- Handle heap request errors *)
(*----------------------------------------------------------------------*)
FUNCTION Heap_Error_Handler( Size : WORD ) : INTEGER;
(*----------------------------------------------------------------------*)
(* *)
(* Function: Heap_Error_Handler *)
(* *)
(* Purpose: Handle heap overflow errors. *)
(* *)
(*----------------------------------------------------------------------*)
BEGIN (* Heap_Error_Handler *)
Heap_Error_Handler := 1;
END (* Heap_Error_Handler *);
(*----------------------------------------------------------------------*)
(* Get_Unix_Style_Date --- Unpack Unix style date *)
(*----------------------------------------------------------------------*)
PROCEDURE Get_Unix_Style_Date( Date : LONGINT;
VAR Year : WORD;
VAR Month : WORD;
VAR Day : WORD;
VAR Hour : WORD;
VAR Mins : WORD;
VAR Secs : WORD );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Get_Unix_Style_Date *)
(* *)
(* Purpose: Converts date in Unix form to ymd, hms form *)
(* *)
(*----------------------------------------------------------------------*)
CONST
Secs_Per_Year = 31536000;
Secs_Per_Leap_Year = 31622400;
Secs_Per_Day = 86400;
Secs_Per_Hour = 3600;
Secs_Per_Minute = 60;
VAR
RDate : LONGINT;
SaveDate : LONGINT;
T : LONGINT;
BEGIN (* Get_Unix_Style_Date *)
(* Starting date is January 1, 1970 *)
Year := 1970;
Month := 1;
RDate := Date - GMT_Difference;
SaveDate := RDate;
(* Sweep out year *)
WHILE( RDate > 0 ) DO
BEGIN
IF ( Year MOD 4 ) = 0 THEN
T := Secs_Per_Leap_Year
ELSE
T := Secs_Per_Year;
RDate := RDate - T;
INC( Year );
END;
RDate := RDate + T;
DEC( Year );
(* Adjust for daylight savings time *)
(* if necessary *)
IF Use_Daylight_Savings THEN
WITH Daylight_Savings_Time[Year] DO
BEGIN
IF ( ( SaveDate >= Starting_Time ) AND
( SaveDate <= Ending_Time ) ) THEN
RDate := RDate + Secs_Per_Hour;
END;
(* Adjust for leap year *)
IF ( ( Year MOD 4 ) = 0 ) THEN
Days_Per_Month[ 2 ] := 29
ELSE
Days_Per_Month[ 2 ] := 28;
(* Sweep out month *)
WHILE( RDate > 0 ) DO
BEGIN
T := LONGINT( Days_Per_Month[ Month ] ) * Secs_Per_Day;
RDate := RDate - T;
INC( Month );
END;
RDate := RDate + T;
DEC( Month );
(* Get day *)
Day := ( RDate + PRED( Secs_Per_Day ) ) DIV Secs_Per_Day;
RDate := RDate - LONGINT( PRED( Day ) ) * Secs_Per_Day;
(* Get time within day *)
Hour := RDate DIV Secs_Per_Hour;
RDate := RDate MOD Secs_Per_Hour;
Mins := RDate DIV Secs_Per_Minute;
Secs := RDate MOD Secs_Per_Minute;
END (* Get_Unix_Style_Date *);
(*----------------------------------------------------------------------*)
(* Set_Unix_Style_Date --- Set UNIX style date *)
(*----------------------------------------------------------------------*)
PROCEDURE Set_Unix_Style_Date( VAR Date : LONGINT;
Year : WORD;
Month : WORD;
Day : WORD;
Hour : WORD;
Mins : WORD;
Secs : WORD );
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Set_Unix_Style_Date *)
(* *)
(* Purpose: Converts date in ymd, hms form to Unix form *)
(* *)
(*----------------------------------------------------------------------*)
CONST
Secs_Per_Year = 31536000;
Secs_Per_Leap_Year = 31622400;
Secs_Per_Day = 86400;
Secs_Per_Hour = 3600;
Secs_Per_Minute = 60;
VAR
T : LONGINT;
Leap_Year : BOOLEAN;
I : INTEGER;
BEGIN (* Set_Unix_Style_Date *)
Date := 0;
(* Add seconds in each year up to *)
(* specified year *)
FOR I := 1970 TO PRED( Year ) DO
BEGIN
IF ( I MOD 4 ) = 0 THEN
T := Secs_Per_Leap_Year
ELSE
T := Secs_Per_Year;
Date := Date + T;
END;
(* Adjust for leap year *)
IF ( Year MOD 4 ) = 0 THEN
Days_Per_Month[2] := 29
ELSE
Days_Per_Month[2] := 28;
(* Add seconds in each month up to *)
(* specified month *)
FOR I := 1 TO PRED( Month ) DO
Date := Date + LONGINT( Days_Per_Month[I] ) * Secs_Per_Day;
(* Add in seconds for current day *)
Date := Date + LONGINT( PRED( Day ) ) * Secs_Per_Day +
LONGINT( Hour ) * Secs_Per_Hour +
LONGINT( Mins ) * Secs_Per_Minute +
Secs;
END (* Set_Unix_Style_Date *);
(*----------------------------------------------------------------------*)
(* Zeller -- Compute day of week for date using Zeller's congruence *)
(*----------------------------------------------------------------------*)
FUNCTION Zeller( Year, Month, Day : WORD ) : INTEGER;
VAR
Century : INTEGER;
Yr : INTEGER;
Temp : INTEGER;
Mon : INTEGER;
DayVal : INTEGER;
BEGIN (* Zeller *)
Mon := Month - 2;
Yr := Year;
IF ( ( Mon < 1 ) OR ( Mon > 10 ) ) THEN
BEGIN
Mon := Mon + 12;
DEC( Yr );
END;
Century := Yr DIV 100;
Yr := Yr MOD 100;
DayVal := ( TRUNC( INT( 2.6 * Mon - 0.2 ) ) + Day + Yr +
( Yr DIV 4 ) + ( Century DIV 4 ) - Century - Century ) MOD 7;
IF ( DayVal < 0 ) THEN
DayVal := DayVal + 7;
Zeller := DayVal;
END (* Zeller *);
(*----------------------------------------------------------------------*)
(*Get_Daylight_Savings_Times --- Get daylight savings time in Unix form *)
(*----------------------------------------------------------------------*)
PROCEDURE Get_Daylight_Savings_Times;
(*----------------------------------------------------------------------*)
(* *)
(* Procedure: Get_Daylight_Savings_Times *)
(* *)
(* Purpose: Initialize table of daylight savings time start and *)
(* stop times in Unix form. *)
(* *)
(* Method: Daylight Savings Time runs from 3 AM on the first *)
(* Sunday in April to 1 AM on the last Sunday of *)
(* October. Zeller's congruence is used to search *)
(* April and October for the relevant Sundays, and *)
(* then the specified times/dates are converted to *)
(* Unix form = # of seconds since January 1, 1970, *)
(* 00:00:00 GMT. *)
(* *)
(*----------------------------------------------------------------------*)
VAR
Year : WORD;
Day : WORD;
CONST
April : WORD = 4;
October : WORD = 10;
BEGIN (* Get_Daylight_Savings_Times *)
(* Loop over years of interest *)
FOR Year := 1980 TO 2000 DO
BEGIN
(* Search April for 1st Sunday *)
Day := 0;
REPEAT
INC( Day );
UNTIL ( Zeller( Year, April, Day ) = 0 );
(* Get starting time for DST in Unix *)
(* format. *)
Set_Unix_Style_Date( Daylight_Savings_Time[Year].Starting_Time,
Year, April, Day, 3, 0, 0 );
(* Search October for last Sunday *)
Day := 32;
REPEAT
DEC( Day );
UNTIL ( Zeller( Year, October, Day ) = 0 );
(* Get ending time for DST in Unix *)
(* format. *)
Set_Unix_Style_Date( Daylight_Savings_Time[Year].Ending_Time,
Year, October, Day, 1, 0, 0 );
END;
END (* Get_Daylight_Savings_Times *);
